home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
OVERRET1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-16
|
31KB
|
1,004 lines
{$R-,S-,I-,D-,F+,V-,B-,N- }
{$M 65500,0,0 }
unit overret1;
interface
uses crt,nuv,
gentypes,modem,configrt,gensubs,subs1,subs2,userret,textret,flags,mainr1;
procedure edituser (eunum:integer);
procedure printnews;
procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
function getlastcaller:mstr;
procedure showlastcallers;
procedure infoform (i:integer);
function selectspecs (var us:userspecsrec):boolean; { True if user aborts }
procedure editoldspecs;
implementation
var buflen30:boolean;
{procedure help (fn:mstr);
var tf:text;
htopic,cnt:integer;
begin
fn:=textfiledir+fn;
assign (tf,fn);
reset (tf);
if ioresult<>0 then begin
writestr ('Sorry, no help is availiable!');
if issysop then begin
writeln ('Sysop: To make help, create a file called ',fn);
writeln ('Group the lines into blocks separated by periods.');
writeln ('The first group is the topic menu; the second is the');
writeln ('help for topic 1; the third for topic 2; etc.')
end;
exit
end;
repeat
textclose (tf);
assign (tf,fn);
reset (tf);
writeln (^M);
printtexttopoint (tf);
repeat
writestr (^M'Topic Number [CR/Quit]:');
if hungupon or (length(input)=0) then
begin
textclose (tf);
exit
end;
htopic:=valu (input)
until (htopic>0);
for cnt:=2 to htopic do
if not eof(tf)
then skiptopoint (tf);
if eof(tf)
then writestr ('Sorry, no help on that topic!')
else printtexttopoint (tf)
until 0=1
end;}
procedure edituser (eunum:integer);
var eurec:userrec;
ca:integer;
k:char;
const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
sectionnames:array [udsysop..gfsysop] of string[20]=
('File transfer','Bulletin section','Voting booths',
'E-mail section','Doors','Main menu','Databases','Trivia','G-Files');
procedure truesysops;
begin
writeln ('Sorry, you may not do that without true sysop access!');
writelog (18,17,'')
end;
function truesysop:boolean;
begin
truesysop:=ulvl<>sysoplevel
end;
procedure eustatus;
var vot:integer;
var lev:real;
begin
clearscr;
movexy (1,8);
writeln (^R' ╔═════════════════════════════════════╗');
writeln (^R' ║ '^P' User Main Level'^R' ║');
writeln (^R' ║ '^P'Name'^R' : ║');
writeln (^R' ║ '^P'Note'^R' : ║');
writeln (^R' ║ '^P'Level'^R' : ║');
writeln (^R' ║ '^P'Password'^R' : ║');
writeln (^R' ║ '^P'Phone'^R' : ║');
writeln (^R' ║ '^P'Time on'^R' : ║');
writeln (^R' ║ '^P'Time Left'^R' : ║');
writeln (^R' ║ '^P'Voting Record'^R' : ║');
writeln (^R' ║ '^P'Wanted Status'^R' : ║');
if useqr then begin
with eurec do begin
qr := qrmultifactor*(eurec.uploads+eurec.nbu)-eurec.downloads;
end;
writeln (^R' ║ '^P'Quality Rating'^R': ║');
end;
writeln (^R' ╚═════════════════════════════════════╝');
printxy (39,10,eurec.handle);
printxy (39,11,eurec.note);
printxy (39,12,strr(eurec.level));
printxy (39,13,eurec.password);
printxy (39,14,eurec.phonenum);
printxy (39,15,streal(eurec.totaltime));
printxy (39,16,strr(eurec.timetoday));
movexy (1,17);
write (^R' ║ '^P'Voting Record'^R' : ');
for vot:=1 to maxtopics do begin { x,y = 38,18 }
if vot<>1 then write (',');
write (^S,eurec.voted[vot]);
end;
printxy (39,18,yesno(wanted in eurec.config)+^R);
if useqr then begin
with eurec do begin
qr := qrmultifactor*(eurec.uploads+eurec.nbu)-eurec.downloads;
end;
printxy (39,19,strr(qr));
end;
printxy (1,1,^R+'╔══════════════════════════════════════════════════════════════════════════════╗');
printxy (1,2,^R+'║ '^P'File Transfer Section'^R' ║');
printxy (1,3,^R+'║ '^P'Transfer Level '^R': '^P'Uploaded K '^R': ║');
printxy (1,4,^R+'║ '^P'Transfer Points'^R': '^P'Downloaded K'^R': ║');
printxy (1,5,^R+'║ '^P'Uploads '^R': '^P'File K Ratio'^R': ║');
printxy (1,6,^R+'║ '^P'Downloads '^R': '^P'U/D Ratio '^R': ║');
printxy (1,7,^R+'╚══════════════════════════════════════════════════════════════════════════════╝');
printxy (20,3,strr(eurec.udlevel));
printxy (20,4,strr(eurec.udpoints));
printxy (20,5,strr(eurec.uploads));
printxy (20,6,strr(eurec.downloads));
printxy (58,3,streal(eurec.upk/1000));
printxy (58,4,streal(eurec.downk/1000));
printxy (58,5,streal(ratio(eurec.upk,eurec.downk))+'%');
printxy (58,6,strr(percent(eurec.uploads,eurec.downloads))+'%');
printxy (1,09,^R'┌──────────────────┐');
printxy (1,10,^R'│ '^P'Level '^R' : │');
printxy (1,11,^R'│ '^P'Uploads '^R': │');
printxy (1,12,^R'│ '^P'Downloads'^R': │');
printxy (1,13,^R'│ '^P'Ratio '^R' : │');
printxy (1,14,^R'└──────────────────┘');
printxy (14,10,strr(eurec.gflevel));
printxy (14,11,strr(eurec.gfuploads));
printxy (14,12,strr(eurec.gfdownloads));
printxy (14,13,strr(percent(eurec.gfuploads,eurec.gfdownloads))+'%');
printxy (60,09,^R'┌───────────────────┐');
printxy (60,10,^R'│ '^P'Posts'^R' : │');
printxy (60,11,^R'│ '^P'Calls'^R' : │');
printxy (60,12,^R'│ '^P'PCR '^R' : │');
printxy (60,13,^R'│ '^P'Last Date'^R': │');
printxy (60,14,^R'│ '^P'Last Time'^R': │');
printxy (60,15,^R'└───────────────────┘');
printxy (73,10,strr(eurec.nbu));
printxy (73,11,strr(eurec.numon));
printxy (73,12,strr(percent(eurec.nbu,eurec.numon))+'%');
if laston<>0 then printxy (73,13,datestr(eurec.laston)) else
printxy (73,13,'None.');
if laston<>0 then printxy (73,14,timestr(eurec.laston)) else
printxy (73,14,'None.');
movexy (1,20);
end;
procedure getmstr (t:mstr; var mm);
var m:mstr absolute mm;
begin
writeln ('Old ',t,': '^S,m);
if buflen30 then buflen:=30;
writestr ('New '+t+'? *');
if length(input)>0 then m:=input
end;
procedure getsstr (t:mstr; var s:sstr);
var m:mstr;
begin
m:=s;
getmstr (t,m);
s:=m
end;
procedure getint (t:mstr; var i:integer);
var m:mstr;
begin
m:=strr(i);
getmstr (t,m);
i:=valu(m)
end;
procedure euwanted;
begin
writestr ('Wanted status: '^S+yesno(wanted in eurec.config));
writestr ('New wanted status:');
if yes
then eurec.config:=eurec.config+[wanted]
else eurec.config:=eurec.config-[wanted];
writelog (18,1,yesno(wanted in eurec.config))
end;
procedure eudel;
begin
writestr ('Delete User? [y/n]: *');
if yes then begin
deleteuser (eunum);
nuvit;
seek (ufile,eunum);
read (ufile,eurec);
writelog (18,9,'')
end
end;
procedure euname;
var m:mstr;
begin
m:=eurec.handle;
getmstr ('name',m);
if not match (m,eurec.handle) then
if lookupuser (m)<>0 then begin
writestr ('Already exists! Are you sure [y/n]? *');
if not yes then exit
end;
eurec.handle:=m;
writelog (18,6,m)
end;
procedure eupassword;
begin
if not truesysop
then truesysops
else begin
getsstr ('Password',eurec.password);
writelog (18,8,'')
end
end;
procedure eulevel;
var n:integer;
begin
n:=eurec.level;
getint ('Level',n);
if (n>=sysoplevel) and (not truesysop)
then truesysops
else begin
eurec.level:=n;
writelog (18,15,strr(n))
end
end;
procedure eugflevel;
var n:integer;
begin
n:=eurec.gflevel;
getint ('G-File Level',n);
if (n>=sysoplevel) and (not truesysop)
then truesysops
else begin
eurec.gflevel:=n;
writelog (18,18,strr(n))
end
end;
procedure euphone;
var m:mstr;
p:integer;
begin
m:=eurec.phonenum;
buflen:=15;
getmstr ('Phone Number',m);
p:=1;
while p<=length(m) do
if (m[p] in ['0'..'9'])
then p:=p+1
else delete (m,p,1);
if length(m)>7 then begin
eurec.phonenum:=m;
writelog (18,16,m)
end
end;
procedure eunote;
var ax:mstr;
begin
buflen30:=true;
getmstr ('User Note',eurec.note);
buflen30:=false;
writeurec;
end;
procedure boardflags;
var quit:boolean;
procedure listflags;
var bd:boardrec;
cnt:integer;
begin
seek (bdfile,0);
for cnt:=0 to filesize(bdfile)-1 do begin
read (bdfile,bd);
tab (bd.shortname,9);
tab (bd.boardname,30);
writeln (accessstr[getuseraccflag (eurec,cnt)]);
if break then exit
end
end;
procedure changeflag;
var bn,q:integer;
bname:mstr;
ac:accesstype;
begin
buflen:=8;
writestr ('Board to change access:');
bname:=input;
bn:=searchboard(input);
if bn=-1 then begin
writeln ('Not found!');
exit
end;
writeln (^B^M'Current access: '^S,
accessstr[getuseraccflag (eurec,bn)]);
getacflag (ac,input);
if ac=invalid then exit;
setuseraccflag (eurec,bn,ac);
case ac of
letin:q:=2;
keepout:q:=3;
bylevel:q:=4
end;
writelog (18,q,bname)
end;
procedure allflags;
var ac:accesstype;
begin
writehdr ('Set all board access flags');
getacflag (ac,input);
if ac=invalid then exit;
writestr ('Confirm [Y/N]:');
if not yes then exit;
setalluserflags (eurec,ac);
writelog (18,5,accessstr[ac])
end;
begin
opentempbdfile;
quit:=false;
repeat
repeat
writestr (^M'[L]ist flags, [C]hange one flag, [A]ll flags, or [Q]uit:');
if hungupon then exit
until length(input)<>0;
case upcase(input[1]) of
'L':listflags;
'C':changeflag;
'A':allflags;
'Q':quit:=true
end
until quit;
closetempbdfile
end;
procedure specialsysop;
procedure getsysop (c:configtype);
begin
writeln ('Section ',sectionnames[c],': '^S,
sysopstr[c in eurec.config]);
writestr ('Grant Sysop Access? *');
if length(input)<>0
then if yes
then
begin
eurec.config:=eurec.config+[c];
writelog (18,10,sectionnames[c])
end
else
begin
eurec.config:=eurec.config-[c];
writelog (18,11,sectionnames[c])
end
end;
begin
if not truesysop then begin
truesysops;
exit
end;
writestr
('Section of [M]ain, [F]ile, [B]ulletin, [V]oting, [E]mail, [D]atabase,'^M+
' [O]Doors, [G]-Files, [J]Trivia: *');
if length(input)=0 then exit;
case upcase(input[1]) of
'M':getsysop (mainsysop);
'F':getsysop (udsysop);
'B':getsysop (bulletinsysop);
'V':getsysop (votingsysop);
'E':getsysop (emailsysop);
'D':getsysop (databasesysop);
'O':getsysop (doorssysop);
'G':getsysop (gfsysop);
'J':getsysop (jsysop)
end
end;
procedure getlogint (prompt:mstr; var i:integer; ln:integer);
begin
getint (prompt,i);
writelog (18,ln,strr(i))
end;
procedure specialediting;
begin
writestr ('Number of Uploads : *');
if (length(input)>0) and (valu(input)>-1) then
eurec.uploads:=valu(input);
writestr ('Number of Downloads : *');
if (length(input)>0) and (valu(input)>-1) then
eurec.downloads:=valu(input);
writestr ('Uploaded Kilobytes : *');
if yes then urec.upk:=0;
writestr ('Downloaded Kilobytes : *');
if yes then urec.downk:=0;
writeufile (eurec,eunum);
end;
procedure conaccess;
var q:char;
begin
repeat
write ('[1] Conference #1 Message: ');
if eurec.defcon[1] then writeln ('TRUE') else writeln ('FALSE');
write ('[2] Conference #2 Message: ');
if eurec.defcon[2] then writeln ('TRUE') else writeln ('FALSE');
write ('[3] Conference #3 Message: ');
if eurec.defcon[3] then writeln ('TRUE') else writeln ('FALSE');
write ('[4] Conference #4 Message: ');
if eurec.defcon[4] then writeln ('TRUE') else writeln ('FALSE');
write ('[5] Conference #5 Message: ');
if eurec.defcon[5] then writeln ('TRUE') else writeln ('FALSE');
write ('[6] Conference #1 Xfer : ');
if eurec.defcon[6] then writeln ('TRUE') else writeln ('FALSE');
write ('[7] Conference #2 Xfer : ');
if eurec.defcon[7] then writeln ('TRUE') else writeln ('FALSE');
write ('[8] Conference #3 Xfer : ');
if eurec.defcon[8] then writeln ('TRUE') else writeln ('FALSE');
write ('[9] Conference #4 Xfer : ');
if eurec.defcon[9] then writeln ('TRUE') else writeln ('FALSE');
write ('[0] Conference #5 Xfer : ');
if eurec.defcon[10] then writeln ('TRUE') else writeln ('FALSE');
writestr (^M'Conference Access, [Q]uit: *');
q:=upcase(input[1]);
case q of
'1':if not eurec.defcon[1] then eurec.defcon[1]:=true else eurec.defcon[1]:=false;
'2':if not eurec.defcon[2] then eurec.defcon[2]:=true else eurec.defcon[2]:=false;
'3':if not eurec.defcon[3] then eurec.defcon[3]:=true else eurec.defcon[3]:=false;
'4':if not eurec.defcon[4] then eurec.defcon[4]:=true else eurec.defcon[4]:=false;
'5':if not eurec.defcon[5] then eurec.defcon[5]:=true else eurec.defcon[5]:=false;
'6':if not eurec.defcon[6] then eurec.defcon[6]:=true else eurec.defcon[6]:=false;
'7':if not eurec.defcon[7] then eurec.defcon[7]:=true else eurec.defcon[7]:=false;
'8':if not eurec.defcon[8] then eurec.defcon[8]:=true else eurec.defcon[8]:=false;
'9':if not eurec.defcon[9] then eurec.defcon[9]:=true else eurec.defcon[9]:=false;
'0':if not eurec.defcon[10] then eurec.defcon[10]:=true else eurec.defcon[10]:=false;
end
until (q=upcase('Q'));
end;
var q,cnt:integer;
begin
writeurec;
seek (ufile,eunum);
read (ufile,eurec);
writelog (2,3,eurec.handle);
writeln (^R'Editing User - '+^S+eurec.handle+^R);
repeat
q:=menu('User Edit','UEDIT','SDHPLOEWTBQYNIRG!VC?');
case q of
1:eustatus;
2:eudel;
3:euname;
4:eupassword;
5:eulevel;
6:getlogint ('File Points',eurec.udpoints,7);
7:getlogint ('File Level',eurec.udlevel,14);
8:euwanted;
9:getlogint ('Time left for today',eurec.timetoday,12);
10:boardflags;
12:specialsysop;
13:euphone;
14:showinfoforms(strr(eunum));
15:eunote;
16:eugflevel;
17:specialediting;
18:begin eurec.level:=qvmainl;
eurec.udlevel:=qvxferl;
eurec.udpoints:=qvxferp;
eurec.gflevel:=qvgfile;
eurec.note:=qvnote;
cnt:=eurec.level;
if cnt<1 then cnt:=1;
if cnt>100 then cnt:=100;
eurec.timetoday:=usertime[cnt];
writeufile (eurec,eunum);
writeln ('User Quick-Validated.');
end;
19:conaccess;
20:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
User Edit Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔═════
s');
writeln ('u
════════════════════════════════╗HC║ [
B
]
s');
writeln ('u
Edit User Sub-Board Flags
║HC║ [
C
s');
writeln ('u
]
Conference Access
║HC║ [
s');
writeln ('u
D
]
Delete User
║H
s');
writeln ('u
C║ [
E
]
Edit Xfer Level
s');
writeln ('u
║HC║ [
G
]
Edit G-File Level
s');
writeln ('u
║HC║ [
H
]
Change User ID
s');
writeln ('u
║HC║ [
I
]
Show Infoforms
s');
writeln ('u
║HC║ [
L
]
Edit Main Le
s');
writeln ('u
vel
║HC║ [
N
]
Edit P
s');
writeln ('u
hone Number
╔═════════════════════════════════════╗
');
writeln ('
HC
║ [
O
]
Edit Xfer Points
s');
writeln ('u
║ [
R
]
Edit User Note
║
');
writeln ('
HC
║ [
P
]
Change Password
s');
writeln ('u
║ [
S
]
Show Statistics
║
');
writeln ('
HC
║ [
Q
]
Quit
s');
writeln ('u
║ [
T
]
Edit Time
║
');
writeln ('
HC
╚═══════════════════════════
║ [
V
s');
writeln ('u
]
Quick Validate User
║HC║
s');
writeln ('u
[
W
]
Edit Wanted Flag
║H
s');
writeln ('u
C║ [
Y
]
Edit Sysop Status
s');
writeln ('u
║HC║ [
?
]
View This Menu
s');
writeln ('u
║HC╚═════════════════════════════════════╝
');
write (^B^R' '^M);
pause;
end;
end
until hungupon or (q=11);
writeufile (eurec,eunum);
readurec
end;
Procedure printnews;
Var nfile:File Of newsrec;
line:Integer;
Ntmp:newsrec;cnt:Integer;
Begin
Assign(nfile,bbsdatadir+'News.dat');
Reset(nfile);
If IOResult<>0 Then exit;
If FileSize(nfile)=0 Then Begin
Close(nfile);
exit
End;
writeln('News: [Ctrl-X] to abort');
cnt:=0;
While Not(EoF(nfile) Or break Or hungupon) Do Begin
Read(nfile,Ntmp);
If (ntmp.location>=0) And (ntmp.maxlevel>=urec.level) And (urec.level>=ntmp.level) Then Begin
inc(cnt);
WriteLn(^B'News Item #'^S,cnt,^R' - "'^S,ntmp.title,^R'" from '^S,ntmp.from,^R'');
WriteLn(^B'Date: ['^S,datestr(ntmp.when),^R'] Level ['^S,ntmp.level,' - ',ntmp.maxlevel,^R']');
printtext(Ntmp.location);
writestr (^M^P'['^R'Enter'^P']'^S': '^U'*')
End;
End;
Close(nfile)
End;
procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
var cnt,ptr:integer;
k:char;
procedure sendit (s:char);
begin
sendchar (s);
end;
begin
ptr:=0;
for ptr:=1 to length(ss) do
begin
if keyhit or (carrier=endifcarrier) then exit;
k:=ss[ptr];
case k of
'|':sendit (^M);
'~':delay (500);
'^':begin
ptr:=ptr+1;
if ptr>length(ss)
then k:='^'
else k:=upcase(ss[ptr]);
if k in ['A'..'Z']
then sendit (chr(ord(k)-64))
else sendit (k)
end;
else sendit(k);
end;
delay(50);
end;
end;
function getlastcaller:mstr;
var qf:file of lastrec;
l:lastrec;
begin
getlastcaller:='';
assign (qf,bbsdatadir+'Callers.dat');
reset (qf);
if ioresult=0 then
if filesize(qf)>0
then
begin
seek (qf,0);
read (qf,l);
getlastcaller:=l.name
end;
close (qf)
end;
{procedure showlastcallers;
var qf:file of lastrec;
cnt:integer;
l:lastrec;
begin
if ulvl<listuserlvl then exit;
assign (qf,bbsdatadir+'Callers.dat');
reset (qf);
if ioresult=0 then begin
writehdr ('Recent Caller List');
break:=false;
writeln ('Name Date Time');
if (asciigraphics in urec.config) then
writeln ('──────────────────────────────────────────────') else
writeln ('----------------------------------------------');
for cnt:=0 to filesize(qf)-1 do
if not break then begin
read (qf,l);
ansicolor (urec.statcolor);
tab (l.name,31);
ansicolor (urec.regularcolor);
writeln (datestr(l.when)+' '+timestr(l.when))
end
end;
close (qf)
end;}
Procedure showlastcallers;
Var qf:File Of lastrec;
cnt:Integer;
l:lastrec;
Begin
if ulvl<listuserlvl then begin
reqlevel (listuserlvl);
exit; end;
Assign(qf,bbsdatadir+'Callers.dat');
Reset(qf);
If ioresult=0 Then Begin
writehdr('Recent Caller List');
writeln (^P'┌──────────────────────────────────┬────────────┬────────────┬────────────┐');
writeln (^P'│ '^R'User Handle '^P'│ '^R'Date '^P'│ '^R'Time '+
^P'│ '^R'Baud Rate '^P'│');
writeln (^P'├──────────────────────────────────┼────────────┼────────────┼────────────┤');
For cnt:=0 To FileSize(qf)-1 Do begin
Read(qf,l);
tab (^P'│ '^S+l.name,37);
tab (^P'│ '^S+(datestr(l.when)),15);
tab (^P'│ '^S+(timestr(l.when)),15);
tab (^P'│ '^S+l.baud,15);
writeln (^P'│');
if Break then Exit;
End;
writeln (^P'└──────────────────────────────────┴────────────┴────────────┴────────────┘'^M);
Close(qf)
End;
End;
procedure infoform (i:integer);
var ff:text;
fn:lstr;
k:char;
me:message;
begin
writeln;
if (i<1) or (i>5) then exit;
fn:=textfiledir+'Infoform.'+strr(i);
if not exist (fn) then begin
writestr ('There isn''t an Info-Form #'+strr(i)+' right now.');
if issysop then
writeln ('Sysop: To make an information form, create a text file',
^M'called ',fn,'. Use * to indicate a pause for user input.');
exit
end;
if i=1 then begin
if urec.infoform1<>-1 then begin
writestr ('You have already filled out Information Form #1! '+^M+
'Replace it [y/n]? *');
if not yes then exit;
deletetext (urec.infoform1);
urec.infoform1:=-1;
writeurec
end;
end;
if i=2 then begin
if urec.infoform2<>-1 then begin
writestr ('You have an existing information form #2! '+^M+
'Replace it [y/n]? *');
if not yes then exit;
deletetext (urec.infoform2);
urec.infoform2:=-1;
writeurec
end;
end;
if i=3 then begin
if urec.infoform3<>-1 then begin
writestr ('You have an existing information form #3! '+^M+
'Replace it [y/n]? *');
if not yes then exit;
deletetext (urec.infoform3);
urec.infoform3:=-1;
writeurec
end;
end;
if i=4 then begin
if urec.infoform4<>-1 then begin
writestr ('You have an existing information form #4! '+^M+
'Replace it [y/n]? *');
if not yes then exit;
deletetext (urec.infoform4);
urec.infoform4:=-1;
writeurec
end;
end;
if i=5 then begin
if urec.infoform5<>-1 then begin
writestr ('You have an existing information form #5! '+^M+
'Replace it [y/n]? *');
if not yes then exit;
deletetext (urec.infoform5);
urec.infoform5:=-1;
writeurec
end;
end;
assign (ff,fn);
reset (ff);
me.numlines:=1;
me.title:='';
me.anon:=false;
me.text[1]:='Filled out on: '+datestr(now)+' at '+timestr(now);
while not eof(ff) do begin
if hungupon then begin
textclose (ff);
exit
end;
read (ff,k);
if k='*' then begin
nochain:=true;
atmenu:=false;
getstr (1);
me.numlines:=me.numlines+1;
me.text[me.numlines]:=input
end else writechar (k)
end;
textclose (ff);
if i=1 then urec.infoform1:=maketext (me) else
if i=2 then urec.infoform2:=maketext (me) else
if i=3 then urec.infoform3:=maketext (me) else
if i=4 then urec.infoform4:=maketext (me) else
if i=5 then urec.infoform5:=maketext (me);
writeurec
end;
procedure openusfile;
const newusers:userspecsrec=(name:'New users';minlevel:1;maxlevel:1;
minlaston:-maxint;maxlaston:maxint;minpcr:-maxint;maxpcr:maxint);
begin
assign (usfile,bbsdatadir+'userspec.dat');
reset (usfile);
if ioresult<>0 then begin
rewrite (usfile);
if logonlevel<>0 then newusers.maxlevel:=logonlevel;
write (usfile,newusers)
end
end;
procedure editspecs (var us:userspecsrec);
procedure get (tex:string; var value:integer; min:boolean);
var vstr:sstr;
begin
buflen:=6;
if abs(value)=maxint then vstr:='None' else vstr:=strr(value);
writestr (tex+' ['+vstr+']:');
if input[0]<>#0
then if upcase(input[1])='N'
then if min
then value:=-maxint
else value:=maxint
else value:=valu(input)
end;
procedure getreal (tex:string; var value:real; min:boolean);
var vstr:sstr;
s:integer;
begin
buflen:=10;
if abs(value)=maxint then vstr:='None' else vstr:=streal(value);
writestr (tex+' ['+vstr+']:');
if length(input)<>0
then if upcase(input[1])='N'
then if min
then value:=-maxint
else value:=maxint
else begin
val (input,value,s);
if s<>0 then value:=0
end
end;
begin
writeln (^B^M'Enter Specifications; N for none.'^M);
buflen:=30;
writestr ('Specification set name ['+us.name+']:');
if length(input)<>0
then if match(input,'N')
then us.name:='Unnamed'
else us.name:=input;
get ('Lowest level',us.minlevel,true);
get ('Highest level',us.maxlevel,true);
get ('Lowest #days since last call',us.minlaston,true);
get ('Highest #days since last call',us.maxlaston,true);
getreal ('Lowest post to call ratio',us.minpcr,true);
getreal ('Highest post to call ratio',us.maxpcr,true)
end;
function getspecs (var us:userspecsrec):integer; { -1:not saved >0:in file }
begin
with us do begin
name:='Unnamed'; { Assumes USFILE is open !! }
minlevel:=-maxint;
maxlevel:=maxint;
minlaston:=-maxint;
maxlaston:=maxint;
minpcr:=-maxint;
maxpcr:=maxint
end;
editspecs (us);
writestr (^M'Save these specs to disk? *');
if yes then begin
seek (usfile,filesize(usfile));
write (usfile,us);
getspecs:=filesize(usfile)
end else getspecs:=-1
end;
function searchspecs (var us:userspecsrec; name:mstr):integer;
var v,pos:integer;
begin
v:=valu(name);
seek (usfile,0);
pos:=1;
while not eof(usfile) do begin
read (usfile,us);
if match(us.name,name) or (valu(name)=pos) then begin
searchspecs:=pos;
exit
end;
pos:=pos+1
end;
searchspecs:=0;
writestr (^M'Not found!')
end;
procedure listspecs;
var us:userspecsrec;
pos:integer;
procedure writeval (n:integer);
begin
if abs(n)=maxint then write (' None') else write(n:7)
end;
procedure writevalreal (n:real);
begin
if abs(n)=maxint then write (' None') else write(n:7:2)
end;
begin
writehdr ('User Specification Sets');
seek (usfile,0);
pos:=0;
tab ('',35);
tab (' Level ',14);
tab (' Last Call ',14);
writeln (' Post/Call Ratio ');
while not (break or eof(usfile)) do begin
pos:=pos+1;
read (usfile,us);
write (pos:3,'. ');
tab (us.name,30);
writeval (us.minlevel);
writeval (us.maxlevel);
writeval (us.minlaston);
writeval (us.maxlaston);
writevalreal (us.minpcr);
writevalreal (us.maxpcr);
writeln
end
end;
function selectaspec (var us:userspecsrec):integer; { 0 = none }
var done:boolean; { -1 = not in file }
pos:integer; { -2 = added to end }
begin
selectaspec:=0;
openusfile;
if filesize(usfile)=0
then selectaspec:=getspecs(us)
else
repeat
if hungupon then exit;
done:=false;
writestr (^M'Specification Set Name (?/List, A/Add):');
if length(input)=0
then done:=true
else if match(input,'A')
then
begin
pos:=getspecs(us);
if pos>0
then selectaspec:=-2
else selectaspec:=-1;
done:=true
end
else if match(input,'?')
then listspecs
else
begin
pos:=searchspecs (us,input);
done:=pos<>0;
selectaspec:=pos
end
until done;
close (usfile)
end;
function selectspecs (var us:userspecsrec):boolean;
var dummy:integer;
begin
dummy:=selectaspec (us);
selectspecs:=dummy=0
end;
procedure deletespecs (pos:integer);
var cnt:integer;
us:userspecsrec;
begin
openusfile;
for cnt:=pos to filesize(usfile)-1 do begin
seek (usfile,cnt);
read (usfile,us);
seek (usfile,cnt-1);
write (usfile,us)
end;
seek (usfile,filesize(usfile)-1);
truncate (usfile);
close (usfile)
end;
procedure editoldspecs;
var pos:integer;
us:userspecsrec;
begin
repeat
pos:=selectaspec (us);
if pos>0 then begin
buflen:=1;
writestr (^M'[E]dit or [D]elete? *');
if length(input)=1 then case upcase(input[1]) of
'E':begin
editspecs (us);
openusfile;
seek (usfile,pos-1);
write (usfile,us);
close (usfile)
end;
'D':deletespecs (pos)
end
end
until (pos=0) or hungupon
end;
begin
buflen30:=false;
end.